home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlstruct.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  11.0 KB  |  461 lines
  1. /* xlstruct.c - the defstruct facility */
  2. /*        Copyright (c) 1988, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <string.h>
  8. #ifdef STRUCTS
  9.  
  10. /* external variables */
  11. extern LVAL xlenv,xlfenv;
  12. extern LVAL s_lambda,s_quote,lk_key,true;
  13. extern char buf[];
  14.  
  15. /* forward declarations */
  16. #ifdef ANSI
  17. void addslot(LVAL slotname,LVAL defexpr,int slotn,LVAL *pargs, LVAL *pbody);
  18. void updateslot(LVAL args,LVAL slotname,LVAL defexpr);
  19. #else
  20. FORWARD void addslot();
  21. FORWARD void updateslot();
  22. #endif
  23.  
  24. /* local variables */
  25. static  char prefix[STRMAX+1];
  26.  
  27. /* xmkstruct - the '%make-struct' function */
  28. LVAL xmkstruct()
  29. {
  30.     LVAL type,val;
  31.     int i;
  32.  
  33.     /* get the structure type */
  34.     type = xlgasymbol();
  35.  
  36.     /* make the structure */
  37.     val = newstruct(type,xlargc);
  38.  
  39.     /* store each argument */
  40.     for (i = 1; moreargs(); ++i)
  41.         setelement(val,i,nextarg());
  42.     xllastarg();
  43.  
  44.     /* return the structure */
  45.     return (val);
  46. }
  47.  
  48. /* xcpystruct - the '%copy-struct' function */
  49. LVAL xcpystruct()
  50. {
  51.     LVAL str,val;
  52.     int size,i;
  53.     str = xlgastruct();
  54.     xllastarg();
  55.     size = getsize(str);
  56.     val = newstruct(getelement(str,0),size-1);
  57.     for (i = 1; i < size; ++i)
  58.         setelement(val,i,getelement(str,i));
  59.     return (val);
  60. }
  61.  
  62. /* xstrref - the '%struct-ref' function */
  63. LVAL xstrref()
  64. {
  65.     LVAL str,val;
  66.     int i;
  67.     str = xlgastruct();
  68.     val = xlgafixnum(); i = (int)getfixnum(val);
  69.     xllastarg();
  70.     if (i >= getsize(str)) /* wrong structure TAA MOD fix*/
  71.         xlerror("Bad structure reference",str);
  72.     return (getelement(str,i));
  73. }
  74.  
  75. /* xstrset - the '%struct-set' function */
  76. LVAL xstrset()
  77. {
  78.     LVAL str,val;
  79.     int i;
  80.     str = xlgastruct();
  81.     val = xlgafixnum(); i = (int)getfixnum(val);
  82.     val = xlgetarg();
  83.     xllastarg();
  84.     if (i >= getsize(str)) /* wrong structure TAA MOD fix*/
  85.         xlerror("Bad structure reference",str);
  86.     setelement(str,i,val);
  87.     return (val);
  88. }
  89.  
  90. /* xstrtypep - the '%struct-type-p' function */
  91. LVAL xstrtypep()
  92. {
  93.     LVAL type,val;
  94.     type = xlgasymbol();
  95.     val = xlgetarg();
  96.     xllastarg();
  97.     return (structp(val) && getelement(val,0) == type ? true : NIL);
  98. }
  99.  
  100. /* xdefstruct - the 'defstruct' special form */
  101. LVAL xdefstruct()
  102. {
  103.     LVAL structname,slotname,defexpr,sym,tmp,args,body;
  104.     LVAL options,oargs,slots;
  105.     char *pname;
  106.     int slotn;
  107.  
  108.     /* protect some pointers */
  109.     xlstkcheck(6);
  110.     xlsave(structname);
  111.     xlsave(slotname);
  112.     xlsave(defexpr);
  113.     xlsave(args);
  114.     xlsave(body);
  115.     xlsave(tmp);
  116.  
  117.     /* initialize */
  118.     args = body = NIL;
  119.     slotn = 0;
  120.  
  121.     /* get the structure name */
  122.     tmp = xlgetarg();
  123.     if (symbolp(tmp)) {
  124.         structname = tmp;
  125.         strcpy(prefix,(char *)getstring(getpname(structname)));
  126.         strcat(prefix,"-");
  127.     }
  128.  
  129.     /* get the structure name and options */
  130.     else if (consp(tmp) && symbolp(car(tmp))) {
  131.         structname = car(tmp);
  132.         strcpy(prefix,(char *)getstring(getpname(structname)));
  133.         strcat(prefix,"-");
  134.  
  135.         /* handle the list of options */
  136.         for (options = cdr(tmp); consp(options); options = cdr(options)) {
  137.  
  138.             /* get the next argument */
  139.             tmp = car(options);
  140.  
  141.             /* handle options that don't take arguments */
  142.             if (symbolp(tmp)) {
  143.                 pname = (char *)getstring(getpname(tmp));
  144.                 xlerror("unknown option",tmp);
  145.             }
  146.  
  147.             /* handle options that take arguments */
  148.             else if (consp(tmp) && symbolp(car(tmp))) {
  149.                 pname = (char *)getstring(getpname(car(tmp)));
  150.                 oargs = cdr(tmp);
  151.  
  152.                 /* check for the :CONC-NAME keyword */
  153.                 if (strcmp(pname,":CONC-NAME") == 0) {
  154.  
  155.                     /* get the name of the structure to include */
  156.                     if (!consp(oargs) || !symbolp(car(oargs)))
  157.                         xlerror("expecting a symbol",oargs);
  158.  
  159.                     /* save the prefix */
  160.                     strcpy(prefix,(char *)getstring(getpname(car(oargs))));
  161.                 }
  162.  
  163.                 /* check for the :INCLUDE keyword */
  164.                 else if (strcmp(pname,":INCLUDE") == 0) {
  165.  
  166.                     /* get the name of the structure to include */
  167.                     if (!consp(oargs) || !symbolp(car(oargs)))
  168.                         xlerror("expecting a structure name",oargs);
  169.                     tmp = car(oargs);
  170.                     oargs = cdr(oargs);
  171.  
  172.                     /* add each slot from the included structure */
  173.                     slots = xlgetprop(tmp,xlenter("*STRUCT-SLOTS*"));
  174.                     for (; consp(slots); slots = cdr(slots)) {
  175.                         if (consp(car(slots)) && consp(cdr(car(slots)))) {
  176.  
  177.                             /* get the next slot description */
  178.                             tmp = car(slots);
  179.  
  180.                             /* create the slot access functions */
  181.                             addslot(car(tmp),car(cdr(tmp)),++slotn,&args,&body);
  182.                         }
  183.                     }
  184.  
  185.                     /* handle slot initialization overrides */
  186.                     for (; consp(oargs); oargs = cdr(oargs)) {
  187.                         tmp = car(oargs);
  188.                         if (symbolp(tmp)) {
  189.                             slotname = tmp;
  190.                             defexpr = NIL;
  191.                         }
  192.                         else if (consp(tmp) && symbolp(car(tmp))) {
  193.                             slotname = car(tmp);
  194.                             defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
  195.                         }
  196.                         else
  197.                             xlerror("bad slot description",tmp);
  198.                         updateslot(args,slotname,defexpr);
  199.                     }
  200.                 }
  201.                 else
  202.                     xlerror("unknown option",tmp);
  203.             }
  204.             else
  205.                 xlerror("bad option syntax",tmp);
  206.         }
  207.     }
  208.  
  209.     /* get each of the structure members */
  210.     while (moreargs()) {
  211.  
  212.         /* get the slot name and default value expression */
  213.         tmp = xlgetarg();
  214.         if (symbolp(tmp)) {
  215.             slotname = tmp;
  216.             defexpr = NIL;
  217.         }
  218.         else if (consp(tmp) && symbolp(car(tmp))) {
  219.             slotname = car(tmp);
  220.             defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
  221.         }
  222.         else
  223.             xlerror("bad slot description",tmp);
  224.  
  225.         /* create a closure for non-trival default expressions */
  226.         if (defexpr != NIL) {
  227.             tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
  228.             setbody(tmp,cons(defexpr,NIL));
  229.             tmp = cons(tmp,NIL);
  230.             defexpr = tmp;
  231.         }
  232.  
  233.         /* create the slot access functions */
  234.         addslot(slotname,defexpr,++slotn,&args,&body);
  235.     }
  236.  
  237.     /* store the slotnames and default expressions */
  238.     xlputprop(structname,args,xlenter("*STRUCT-SLOTS*"));
  239.  
  240.     /* enter the MAKE-xxx symbol */
  241.     sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
  242.     sym = xlenter(buf);
  243.  
  244.     /* make the MAKE-xxx function */
  245.     args = cons(lk_key,args);
  246.     tmp = cons(structname,NIL);
  247.     tmp = cons(s_quote,tmp);
  248.     body = cons(tmp,body);
  249.     body = cons(xlenter("%MAKE-STRUCT"),body);
  250.     body = cons(body,NIL);
  251.     setfunction(sym,
  252.                 xlclose(sym,s_lambda,args,body,xlenv,xlfenv));
  253.  
  254.     /* enter the xxx-P symbol */
  255.     sprintf(buf,"%s-P",getstring(getpname(structname)));
  256.     sym = xlenter(buf);
  257.  
  258.     /* make the xxx-P function */
  259.     args = cons(xlenter("X"),NIL);
  260.     body = cons(xlenter("X"),NIL);
  261.     tmp = cons(structname,NIL);
  262.     tmp = cons(s_quote,tmp);
  263.     body = cons(tmp,body);
  264.     body = cons(xlenter("%STRUCT-TYPE-P"),body);
  265.     body = cons(body,NIL);
  266.     setfunction(sym,
  267.                 xlclose(sym,s_lambda,args,body,NIL,NIL));
  268.  
  269.     /* enter the COPY-xxx symbol */
  270.     sprintf(buf,"COPY-%s",getstring(getpname(structname)));
  271.     sym = xlenter(buf);
  272.  
  273.     /* make the COPY-xxx function */
  274.     args = cons(xlenter("X"),NIL);
  275.     body = cons(xlenter("X"),NIL);
  276.     body = cons(xlenter("%COPY-STRUCT"),body);
  277.     body = cons(body,NIL);
  278.     setfunction(sym,
  279.                 xlclose(sym,s_lambda,args,body,NIL,NIL));
  280.  
  281.     /* restore the stack */
  282.     xlpopn(6);
  283.  
  284.     /* return the structure name */
  285.     return (structname);
  286. }
  287.  
  288. /* xlrdstruct - convert a list to a structure (used by the reader) */
  289. /* Modified by TAA to quote arguments and accept leading colons on keys */
  290. LVAL xlrdstruct(list)
  291.   LVAL list;
  292. {
  293.     LVAL structname,slotname,expr,last,val;
  294.  
  295.     /* protect the new structure */
  296.     xlsave1(expr);
  297.  
  298.     /* get the structure name */
  299.     if (!consp(list) || !symbolp(car(list)))
  300.     xlerror("bad structure initialization list",list);
  301.     structname = car(list);
  302.     list = cdr(list);
  303.  
  304.     /* enter the MAKE-xxx symbol */
  305.     sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
  306.  
  307.     /* initialize the MAKE-xxx function call expression */
  308.     expr = cons(xlenter(buf),NIL);
  309.     last = expr;
  310.  
  311.     /* turn the rest of the initialization list into keyword arguments */
  312.     while (consp(list) && consp(cdr(list))) {
  313.  
  314.     /* get the slot keyword name */
  315.     slotname = car(list);
  316.     if (!symbolp(slotname))
  317.         xlerror("expecting a slot name",slotname);
  318.  
  319.  
  320.     /* add the slot keyword */
  321.     if (*(getstring(getpname(slotname))) != ':') { /* add colon */
  322.         sprintf(buf,":%s",getstring(getpname(slotname)));
  323.         rplacd(last,cons(xlenter(buf),NIL));
  324.     }
  325.     else {
  326.         rplacd(last,cons(slotname,NIL));
  327.     }
  328.     last = cdr(last);
  329.     list = cdr(list);
  330.  
  331.     /* add the value expression  -- QUOTED (TAA MOD) */
  332.     rplacd(last,cons(NIL,NIL));
  333.     last = cdr(last);
  334.     rplaca(last, (slotname = cons(s_quote,NIL)));
  335.     rplacd(slotname, cons(car(list), NIL));
  336.     list = cdr(list);
  337.     }
  338.  
  339.     /* make sure all of the initializers were used */
  340.     if (consp(list))
  341.     xlerror("bad structure initialization list",list);
  342.  
  343.     /* invoke the creation function */
  344.     val = xleval(expr);
  345.  
  346.     /* restore the stack */
  347.     xlpop();
  348.  
  349.     /* return the new structure */
  350.     return (val);
  351. }
  352.  
  353. /* xlprstruct - print a structure (used by printer) */
  354. void xlprstruct(fptr,vptr,flag)
  355.  LVAL fptr,vptr; int flag;
  356. {
  357.     LVAL next;
  358.     int i,n;
  359.     xlputstr(fptr,"#S(");    /* TAA MOD */
  360.     xlprint(fptr,getelement(vptr,0),flag);
  361.     next = xlgetprop(getelement(vptr,0),xlenter("*STRUCT-SLOTS*"));
  362.     for (i = 1, n = getsize(vptr) - 1; i <= n && consp(next); ++i) {
  363.         if (consp(car(next))) { /* should always succeed */
  364.             xlputstr(fptr," :");    /* TAA MOD, colons should show */
  365.             xlprint(fptr,car(car(next)),flag);
  366.             xlputc(fptr,' ');
  367.             xlprint(fptr,getelement(vptr,i),flag);
  368.         }
  369.         next = cdr(next);
  370.     }
  371.     xlputc(fptr,')');
  372. }
  373.  
  374. /* addslot - make the slot access functions */
  375. LOCAL void addslot(slotname,defexpr,slotn,pargs,pbody)
  376.  LVAL slotname,defexpr; int slotn; LVAL *pargs,*pbody;
  377. {
  378.     LVAL sym,args,body,tmp;
  379.  
  380.     /* protect some pointers */
  381.     xlstkcheck(4);
  382.     xlsave(sym);
  383.     xlsave(args);
  384.     xlsave(body);
  385.     xlsave(tmp);
  386.  
  387.     /* construct the update function name */
  388.     sprintf(buf,"%s%s",prefix,getstring(getpname(slotname)));
  389.     sym = xlenter(buf);
  390.  
  391.     /* make the access function */
  392.     args = cons(xlenter("S"),NIL);
  393.     body = cons(cvfixnum((FIXTYPE)slotn),NIL);
  394.     body = cons(xlenter("S"),body);
  395.     body = cons(xlenter("%STRUCT-REF"),body);
  396.     body = cons(body,NIL);
  397.     setfunction(sym,
  398.                 xlclose(sym,s_lambda,args,body,NIL,NIL));
  399.  
  400.     /* make the update function */
  401.     args = cons(xlenter("V"),NIL);
  402.     args = cons(xlenter("S"),args);
  403.     body = cons(xlenter("V"),NIL);
  404.     body = cons(cvfixnum((FIXTYPE)slotn),body);
  405.     body = cons(xlenter("S"),body);
  406.     body = cons(xlenter("%STRUCT-SET"),body);
  407.     body = cons(body,NIL);
  408.     xlputprop(sym,
  409.               xlclose(NIL,s_lambda,args,body,NIL,NIL),
  410.               xlenter("*SETF*"));
  411.  
  412.     /* add the slotname to the make-xxx keyword list */
  413.     tmp = cons(defexpr,NIL);
  414.     tmp = cons(slotname,tmp);
  415.     tmp = cons(tmp,NIL);
  416.     if ((args = *pargs) == NIL)
  417.         *pargs = tmp;
  418.     else {
  419.         while (cdr(args) != NIL)
  420.             args = cdr(args);
  421.         rplacd(args,tmp);
  422.     }
  423.  
  424.     /* add the slotname to the %make-xxx argument list */
  425.     tmp = cons(slotname,NIL);
  426.     if ((body = *pbody) == NIL)
  427.         *pbody = tmp;
  428.     else {
  429.         while (cdr(body) != NIL)
  430.             body = cdr(body);
  431.         rplacd(body,tmp);
  432.     }
  433.  
  434.     /* restore the stack */
  435.     xlpopn(4);
  436. }
  437.  
  438. /* updateslot - update a slot definition */
  439. LOCAL void updateslot(args,slotname,defexpr)
  440.  LVAL args,slotname,defexpr;
  441. {
  442.     LVAL tmp;
  443.     for (; consp(args); args = cdr(args))
  444.         if (slotname == car(car(args))) {
  445.             if (defexpr != NIL) {
  446.                 xlsave1(tmp);
  447.                 tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
  448.                 setbody(tmp,cons(defexpr,NIL));
  449.                 tmp = cons(tmp,NIL);
  450.                 defexpr = tmp;
  451.                 xlpop();
  452.             }
  453.             rplaca(cdr(car(args)),defexpr);
  454.             break;
  455.         }
  456.     if (args == NIL)
  457.         xlerror("unknown slot name",slotname);
  458. }
  459.  
  460. #endif
  461.